Home

Column

NEON Forecast sites

Column

Stats

Challenges

5

Teams

45

Total Forecasts

1174

Phenology

Column

Phenology

Column

Forecast Submissions

Teams

21

Leaderboard

Aquatics

Column

Aquatics Forecasts

Column

Leaderboard

Terrestrial

Column

Terrestrial Forecasts (Daily)

Terrestrial Forecasts (30 minute)

Column

Leaderboard (daily)

Leaderboard (30 minute)

Ticks

Column

Ticks

Column

Leaderboard

Beetles

Column

Beetles Forecasts

Column

Leaderboard

---
title: "NEON4CAST Dashboard"
output:
  flexdashboard::flex_dashboard:
    theme: 
      version: 4
      bootswatch: lux
    orientation: columns
    vertical_layout: fill
    source_code: embed
---

```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(plotly)
library(clock)
source("R/plotly_helpers.R")

thematic::thematic_rmd(font = "auto")
```


Home
=====



```{r include=FALSE}
combined <- read_csv("https://data.ecoforecast.org/analysis/combined_forecasts_scores.csv.gz")
```


Column {data-width=650}
-----------------------------------------------------------------------


### NEON Forecast sites

```{r}
## FIXME color code by number of challenges at each site?

challenges <- combined %>% select(theme, siteID) %>% distinct() %>%
  separate(siteID, into = c("siteID", "plot")) %>%
  select(theme, siteID) %>% 
  distinct() 
  


library(sf)
library(tmap)
geo <- jsonlite::read_json("https://github.com/eco4cast/neon4cast/raw/main/inst/extdata/geo.json", TRUE)
site_id <- gsub(", .*$", "", geo$geographicDescription)
bb <- geo$boundingCoordinates[1:4] %>% mutate_all(as.numeric) %>% mutate(siteID = site_id)
bb <- left_join(bb, challenges, by = "siteID")
neon <- st_as_sf(bb, coords = c("westBoundingCoordinate", "northBoundingCoordinate"), crs = 4326)

tmap::tmap_mode("view")
tm_shape(neon) + tm_dots(col="theme", alpha=.4, size = .1)
```

Column {data-width=350}
-----------------------------------------------------------------------

## Stats

### Challenges 


```{r}
flexdashboard::valueBox(5, color = "primary")
```

### Teams

```{r}
total_teams <- combined %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total_teams, color = "success")
```



### Total Forecasts

```{r}
total_forecasts <- combined %>% select(team, forecast_start_time) %>% distinct() %>% count()
flexdashboard::valueBox(total_forecasts, color = "info")
```





Phenology
==========


Column {data-width=650}
-----------------------------------------------------------------------

### Phenology

```{r}
## determine these more cleverly
start <- as.Date("2021-05-01")
end <- Sys.Date() %>% clock::add_months(1)

## Get most recent submission per team
pheno_teams <- combined %>% filter(theme == "phenology") %>%
  select(team, forecast_start_time) %>% distinct() %>%
  group_by(team) %>%
  slice_max(forecast_start_time)

pheno_latest <- inner_join(pheno_teams, combined)

p <- pheno_latest %>% 
  filter(time > start, time < end) %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs), size = .1) + 
  facet_wrap(~siteID)

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```

Column {data-width=350}
-----------------------------------------------------------------------

### Forecast Submissions

```{r}
pheno_forecasts <- combined %>% filter(theme == "phenology") %>%
  select(team, forecast_start_time) %>% distinct() %>% count()

gauge(100* pheno_forecasts[[1]]/total_forecasts[[1]], min = 0, max = 100, symbol = '%', gaugeSectors(
  success = c(80, 100), warning = c(40, 79), danger = c(0, 39)
))
```

### Teams

```{r}
total <- combined %>% filter(theme == "phenology") %>% select(team) %>% distinct() %>% count()
flexdashboard::valueBox(total)
```

### Leaderboard

```{r}
pheno_latest %>% 
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```


Aquatics
========

Column {data-width=650}
-----------------------------------------------------------------------


### Aquatics Forecasts

```{r}

## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "aquatics") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "aquatics", forecast_start_time == start[[2,1]]) %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_wrap(target~siteID, scales = "free")

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```

Column {data-width=350}
-----------------------------------------------------------------------


### Leaderboard

```{r}
combined %>% 
  filter(theme == "aquatics") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```

Terrestrial
===========

Column {data-width=650}
-----------------------------------------------------------------------

### Terrestrial Forecasts (Daily)

```{r}
## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "terrestrial_daily") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "terrestrial_daily", forecast_start_time == start[[2,1]]) %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_grid(target ~ siteID, scales = "free")

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```


### Terrestrial Forecasts (30 minute)

```{r}
## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "terrestrial_30min") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "terrestrial_30min", forecast_start_time == start[[2,1]]) %>%
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_grid(target ~ siteID, scales = "free")

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```

Column {data-width=350}
-----------------------------------------------------------------------


### Leaderboard (daily)

```{r}
combined %>% 
  filter(theme == "terrestrial_daily") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```
### Leaderboard (30 minute)

```{r}
combined %>% 
  filter(theme == "terrestrial_daily") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```

Ticks
=======

Column {data-width=650}
-----------------------------------------------------------------------

### Ticks

```{r}
## Could consider displaying older ones
start <- combined %>% 
  filter(theme == "ticks") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "ticks", forecast_start_time == start[[2,1]]) %>% # second most recent start time
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team, lty=target), alpha = 0.2) +
  geom_line(aes(time, mean, col = team, lty=target)) +
  geom_point(aes(time, obs, shape=target)) + 
  facet_wrap(~siteID)

gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```


Column {data-width=350}
-----------------------------------------------------------------------

### Leaderboard

```{r}
combined %>% 
  filter(theme == "ticks") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```


Beetles
=======

Column {data-width=650}
-----------------------------------------------------------------------

### Beetles Forecasts

```{r}
## determine these more cleverly
start <- combined %>% 
  filter(theme == "beetles") %>%
  select(forecast_start_time) %>% 
  distinct() %>% 
  arrange(desc(forecast_start_time))

p <- combined %>%
  filter(theme == "beetles", forecast_start_time == start[[1,1]]) %>% # second most recent start time
  ggplot() +
  geom_ribbon(aes(x = time, ymin = lower95, ymax = upper95, fill = team), alpha = 0.2) +
  geom_line(aes(time, mean, col = team)) +
  geom_point(aes(time, obs)) + 
  facet_wrap(~target)


gp <- plotly::ggplotly(p)
gp <- patch_legend(gp)

gp
```


Column {data-width=350}
-----------------------------------------------------------------------


### Leaderboard

```{r}
combined %>% 
  filter(theme == "beetles") %>%
  group_by(team) %>%
  summarise(mean_crps = mean(crps,na.rm=TRUE)) %>%
  arrange(mean_crps) %>%
  rmarkdown::paged_table()
```